home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 2.iso / dist / fw_guile.idb / usr / freeware / share / guile / 1.4 / ice-9 / mapping.scm.z / mapping.scm
Text File  |  2002-07-08  |  5KB  |  123 lines
  1. ;;; installed-scm-file
  2.  
  3. ;;;;     Copyright (C) 1996 Free Software Foundation, Inc.
  4. ;;;; 
  5. ;;;; This program is free software; you can redistribute it and/or modify
  6. ;;;; it under the terms of the GNU General Public License as published by
  7. ;;;; the Free Software Foundation; either version 2, or (at your option)
  8. ;;;; any later version.
  9. ;;;; 
  10. ;;;; This program is distributed in the hope that it will be useful,
  11. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13. ;;;; GNU General Public License for more details.
  14. ;;;; 
  15. ;;;; You should have received a copy of the GNU General Public License
  16. ;;;; along with this software; see the file COPYING.  If not, write to
  17. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18. ;;;; Boston, MA 02111-1307 USA
  19. ;;;; 
  20.  
  21.  
  22.  
  23. (define-module (ice-9 mapping)
  24.   :use-module (ice-9 poe))
  25.  
  26. (define-public mapping-hooks-type (make-record-type 'mapping-hooks '(get-handle
  27.                                      create-handle
  28.                                      remove)))
  29.  
  30.  
  31. (define-public make-mapping-hooks (perfect-funcq 17 (record-constructor mapping-hooks-type)))
  32. (define-public mapping-hooks? (record-predicate mapping-hooks-type))
  33. (define-public mapping-hooks-get-handle (record-accessor mapping-hooks-type 'get-handle))
  34. (define-public mapping-hooks-create-handle (record-accessor mapping-hooks-type 'create-handle))
  35. (define-public mapping-hooks-remove (record-accessor mapping-hooks-type 'remove))
  36.  
  37. (define-public mapping-type (make-record-type 'mapping '(hooks data)))
  38. (define-public make-mapping (record-constructor mapping-type))
  39. (define-public mapping? (record-predicate mapping-type))
  40. (define-public mapping-hooks (record-accessor mapping-type 'hooks))
  41. (define-public mapping-data (record-accessor mapping-type 'data))
  42. (define-public set-mapping-hooks! (record-modifier mapping-type 'hooks))
  43. (define-public set-mapping-data! (record-modifier mapping-type 'data))
  44.  
  45. (define-public (mapping-get-handle map key)
  46.   ((mapping-hooks-get-handle (mapping-hooks map)) map key))
  47. (define-public (mapping-create-handle! map key . opts)
  48.   (apply (mapping-hooks-create-handle (mapping-hooks map)) map key opts))
  49. (define-public (mapping-remove! map key)
  50.   ((mapping-hooks-remove (mapping-hooks map)) map key))
  51.  
  52. (define-public (mapping-ref map key . dflt)
  53.   (cond
  54.    ((mapping-get-handle map key)    => cdr)
  55.    (dflt                => car)
  56.    (else                #f)))
  57.  
  58. (define-public (mapping-set! map key val)
  59.   (set-cdr! (mapping-create-handle! map key #f) val))
  60.  
  61.  
  62.  
  63. (define-public hash-table-mapping-hooks
  64.   (let ((wrap (lambda (proc) (lambda (1st . rest) (apply proc (mapping-data 1st) rest)))))
  65.  
  66.     (perfect-funcq 17
  67.            (lambda (hash-proc assoc-proc delete-proc)
  68.              (let ((procs (list hash-proc assoc-proc delete-proc)))
  69.                (cond
  70.             ((equal? procs `(,hashq ,assq ,delq!))
  71.              (make-mapping-hooks (wrap hashq-get-handle)
  72.                          (wrap hashq-create-handle!)
  73.                          (wrap hashq-remove!)))
  74.             ((equal? procs `(,hashv ,assv ,delv!))
  75.              (make-mapping-hooks (wrap hashv-get-handle)
  76.                          (wrap hashv-create-handle!)
  77.                          (wrap hashv-remove!)))
  78.             ((equal? procs `(,hash ,assoc ,delete!))
  79.              (make-mapping-hooks (wrap hash-get-handle)
  80.                          (wrap hash-create-handle!)
  81.                          (wrap hash-remove!)))
  82.             (else
  83.              (make-mapping-hooks (wrap
  84.                           (lambda (table key)
  85.                         (hashx-get-handle hash-proc assoc-proc table key)))
  86.                          (wrap
  87.                           (lambda (table key)
  88.                         (hashx-create-handle hash-proc assoc-proc table key)))
  89.                          (wrap
  90.                           (lambda (table key)
  91.                         (hashx-get-handle hash-proc assoc-proc delete-proc table key)))))))))))
  92.  
  93. (define-public (make-hash-table-mapping table hash-proc assoc-proc delete-proc)
  94.   (make-mapping (hash-table-mapping-hooks hash-proc assoc-proc delete-proc) table))
  95.  
  96. (define-public (hash-table-mapping . options)
  97.   (let* ((size (or (and options (number? (car options)) (car options))
  98.            71))
  99.      (hash-proc (or (kw-arg-ref options :hash-proc) hash))
  100.      (assoc-proc (or (kw-arg-ref options :assoc-proc)
  101.              (cond
  102.               ((eq? hash-proc hash) assoc)
  103.               ((eq? hash-proc hashv) assv)
  104.               ((eq? hash-proc hashq) assq)
  105.               (else (error 'hash-table-mapping
  106.                        "Hash-procedure specified with no known assoc function."
  107.                        hash-proc)))))
  108.      (delete-proc (or (kw-arg-ref options :delete-proc)
  109.               (cond
  110.                ((eq? hash-proc hash) delete!)
  111.                ((eq? hash-proc hashv) delv!)
  112.                ((eq? hash-proc hashq) delq!)
  113.                (else (error 'hash-table-mapping
  114.                     "Hash-procedure specified with no known delete function."
  115.                     hash-proc)))))
  116.      (table-constructor (or (kw-arg-ref options :table-constructor)
  117.                 (lambda (len) (make-vector len '())))))
  118.     (make-hash-table-mapping (table-constructor size)
  119.                  hash-proc
  120.                  assoc-proc
  121.                  delete-proc)))
  122.  
  123.